unit MainForm;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
  ActnList;

type

  { TMainFrm }

  TMainFrm = class(TForm)
    acInstall: TAction;
    ActionList1: TActionList;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    LabeledEdit1: TLabeledEdit;
    SelectDirectoryDialog1: TSelectDirectoryDialog;
    procedure acInstallExecute(Sender: TObject);
    procedure acInstallUpdate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Label4Click(Sender: TObject);
    procedure LabeledEdit1Change(Sender: TObject);
    Procedure OnOpenInputStream(Sender: TObject; var AStream: TStream);
  private
    FTempStream: TStream;
    function GetLazarusVersion(Directory: String; var Version: String): Boolean;
    function GetFPCDirectory(Directory: String): String;
    function AddResourceInfoToFPCCFG(FileName: String): Boolean;
  public

  end;

const
  DefaultVersion = '2.2.6';

var
  MainFrm: TMainFrm;
  SupportedVersion: Boolean;

implementation
uses
  LCLType, Zipper, AboutForm;

{$R *.lfm}

{ TMainFrm }

procedure TMainFrm.Button1Click(Sender: TObject);
begin
  if DirectoryExists(LabeledEdit1.Text) then
     SelectDirectoryDialog1.InitialDir := LabeledEdit1.Text;

  if SelectDirectoryDialog1.Execute then
     LabeledEdit1.Text := SelectDirectoryDialog1.FileName;
end;

procedure TMainFrm.acInstallExecute(Sender: TObject);
var
  Version: String = '';
  Res: TFPResourceHandle;
  FPCDirectory, FPCCFGFileName: String;
  S: TResourceStream;
  UnZipper: TUnZipper;

begin
  if not GetLazarusVersion(LabeledEdit1.Text, Version) then
  begin
    if MessageDlg('错误', Version + #13#10'您确定要强行安装吗？', mtError, mbYesNo, 0) <> mrYes then
      Exit;
    Version := '未知版本';
  end;

  Res := FindResource(HInstance, Version + '.ERRORCN', RT_RCDATA);
  if Res = 0 then
  begin
    if MessageDlg('信息', '未找到 ' + Version + ' 的中文资源文件，是否使用 ' + DefaultVersion + ' 的中文资源文件继续安装？', mtInformation, mbYesNo, 0) <> mrYes then
      Exit;
    Version := DefaultVersion;
  end;

  if CheckBox1.Checked then
  begin
    Res := FindResource(HInstance, Version + '.ERRORCN', RT_RCDATA);
    if Res = 0 then
    begin
      MessageDlg('错误', '未找到这个版本：' + Version + ' 的中文资源文件', mtError, [mbOK], 0);
      Exit;
    end;

    FPCDirectory := GetFPCDirectory(LabeledEdit1.Text);
    if (FPCDirectory = '') or (not DirectoryExists(FPCDirectory + '\msg')) then
    begin
      MessageDlg('错误', '未找到FPC目录', mtError, [mbOK], 0);
      Exit;
    end;

    S := TResourceStream.Create(HInstance, Version + '.ERRORCN', RT_RCDATA);
    S.SaveToFile(FPCDirectory + '\msg\errorcn.msg');
    S.Free;

    FPCCFGFileName := FPCDirectory + '\bin\x86_64-win64\fpc.cfg';
    if FileExists(FPCCFGFileName) then
       if not AddResourceInfoToFPCCFG(FPCCFGFileName) then
       begin
         MessageDlg('错误', '修改文件失败！' + FPCCFGFileName, mtError, [mbOK], 0);
       end;

    FPCCFGFileName := FPCDirectory + '\bin\i386-win32\fpc.cfg';
    if FileExists(FPCCFGFileName) then
       if not AddResourceInfoToFPCCFG(FPCCFGFileName) then
       begin
         MessageDlg('错误', '修改文件失败！' + FPCCFGFileName, mtError, [mbOK], 0);
       end;
  end;

  if CheckBox2.Checked then
  begin
    Res := FindResource(HInstance, Version + '.OICN', RT_RCDATA);
    if Res = 0 then
    begin
      MessageDlg('错误', '未找到这个版本：' + Version + ' 的中文资源文件', mtError, [mbOK], 0);
      Exit;
    end;

    if not DirectoryExists(LabeledEdit1.Text + '\docs\xml\lcl') then
    begin
      MessageDlg('错误', '资源目录不存在：' + LabeledEdit1.Text + '\docs\xml\lcl', mtError, [mbOK], 0);
      Exit;
    end;

    S := TResourceStream.Create(HInstance, Version + '.OICN', RT_RCDATA);
    FTempStream := S;
    UnZipper := TUnZipper.Create;
    Try
      UnZipper.OnOpenInputStream := @OnOpenInputStream;
      UnZipper.OutputPath := LabeledEdit1.Text + '\docs\xml\lcl';
      UnZipper.Examine;
      UnZipper.UnZipAllFiles;
    finally
      UnZipper.Free;
    end;
    FTempStream := nil;
    S.Free;
  end;
  MessageDlg('成功', '安装完成!', mtInformation, [mbOK], 0);
end;

procedure TMainFrm.acInstallUpdate(Sender: TObject);
begin
  acInstall.Enabled := CheckBox1.Checked or CheckBox2.Checked;
end;

procedure TMainFrm.Button3Click(Sender: TObject);
begin
  Close;
end;

procedure TMainFrm.FormCreate(Sender: TObject);
var
  C: Char;
begin
  for C := 'C' to 'Z' do
  begin
    if DirectoryExists(C + ':\lazarus') then
    begin
      LabeledEdit1.Text := C + ':\lazarus';
      Exit;
    end;
  end;
end;

procedure TMainFrm.Label4Click(Sender: TObject);
begin
  AboutFrm.ShowModal;
end;

procedure TMainFrm.LabeledEdit1Change(Sender: TObject);
var
  Version: String = '';
  IsLazarusDir, IsFindResource: Boolean;
  Res: TFPResourceHandle;
begin
  IsLazarusDir := GetLazarusVersion(LabeledEdit1.Text, Version);
  Label2.Caption := Version;

  //CheckBox1.Enabled := False;
  //CheckBox1.Checked := False;
  //CheckBox2.Enabled := False;
  //CheckBox2.Checked := False;

  if not IsLazarusDir then Exit;

  IsFindResource := False;
  Res := FindResource(HInstance, Version + '.ERRORCN', RT_RCDATA);
  if Res <> 0 then
  begin
    //CheckBox1.Enabled := True;
    //CheckBox1.Checked := True;
    IsFindResource := True;
  end;

  Res := FindResource(HInstance, Version + '.OICN', RT_RCDATA);
  if Res <> 0 then
  begin
    //CheckBox2.Enabled := True;
    //CheckBox2.Checked := True;
    IsFindResource := True;
  end;

  if not IsFindResource then Label2.Caption := Version + '，不支持的版本，强行安装可能出现不可预知的问题';
end;

procedure TMainFrm.OnOpenInputStream(Sender: TObject; var AStream: TStream);
begin
  AStream := TMemoryStream.Create;
  FTempStream.Position := 0;
  AStream.CopyFrom(FTempStream, FTempStream.Size);
end;

function TMainFrm.GetLazarusVersion(Directory: String; var Version: String): Boolean;
var
  FileContent: String;
  FileName: String;
begin
  Result := False;
  if Directory = '' then Exit;

  if not DirectoryExists(LabeledEdit1.Text) then
  begin
    Version := '您选择的目录不存在！';
    Exit;
  end;

  FileName := LabeledEdit1.Text + '\ide\version.inc';

  if not FileExists(FileName) then
  begin
    FileName := LabeledEdit1.Text + '\ide\packages\ideconfig\version.inc';
    if not FileExists(FileName) then
    begin
      Version := '您选择的目录不是 Lazarus 安装目录或未知的 Lazarus 版本！';
      Exit;
    end;
  end;

  FileContent := GetFileAsString(FileName, TEncoding.ANSI);
  Version := Trim(StringReplace(FileContent, '''', '', [rfReplaceAll]));
  Result := True;
end;

function TMainFrm.GetFPCDirectory(Directory: String): String;
var
  Dir: TSearchRec;
begin
  Result := '';
  if FindFirst(Directory + '\fpc\*', faDirectory, Dir) <> 0 then Exit;
  Repeat
    if (Dir.Name <> '.') and (Dir.Name <> '..') then Break;
  until FindNext(Dir) <> 0;
  Result := Directory + '\fpc\' + Dir.Name;
  FindClose(Dir);
end;

function TMainFrm.AddResourceInfoToFPCCFG(FileName: String): Boolean;
var
  SL: TStringList;
  I, Index: Integer;
  Value: String;
begin
  Result := False;
  SL := TStringList.Create;
  try
    try
      SL.LoadFromFile(FileName);
      Index := -1;
      for I := 0 to SL.Count - 1 do
      begin
        if SL[I].StartsWith('-Fr') then
        begin
          Index := I;
          Break;
        end;
      end;
      Value := '-Fr' + LabeledEdit1.Text + '\fpc\$FPCVERSION/msg/errorcn.msg';
      if Index = -1 then SL.Add(Value)
      else SL[Index] := Value;

      SL.SaveToFile(FileName);
    except
      Exit;
    end;
  finally
    SL.Free;
  end;
  Result := True;
end;

end.

